Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/forth/pfe-0.000/pfe-0/pfe-0.9.13/demo/tetris.4th

Text File | 1994-11-04 | 8.8 KB | 373 lines

\
\ tetris.4th    Tetris for terminals, redone in ANSI-Forth.
\        Written 05Apr94 by Dirk Uwe Zoller, e-mail:
\            [e-mail].
\        Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS"
\
\        Please copy and share this program, modify it for your system
\        and improve it as you like. But don't remove this notice.
\
\        Thank you.
\
\        Changes:
\
\

ONLY FORTH DEFINITIONS
S" FORGET-TT" DROP 1 CHARS - FIND NIP [IF] FORGET-TT [THEN]
MARKER FORGET-TT

WORDLIST CONSTANT TETRIS
GET-ORDER TETRIS DUP ROT 2 + SET-ORDER DEFINITIONS

DECIMAL

\ Variables, constants

BL BL 2CONSTANT EMPTY        \ an empty position
VARIABLE WIPING            \ if true: wipe brick, else draw brick
2 CONSTANT COL0            \ position of the pit on screen
0 CONSTANT ROW0

10 CONSTANT WIDE        \ size of pit in brick positions
20 CONSTANT DEEP

CHAR J    VALUE LEFT-KEY        \ customize if you don't like them
CHAR K    VALUE ROT-KEY
CHAR L    VALUE RIGHT-KEY
BL    VALUE DROP-KEY
CHAR P    VALUE PAUSE-KEY
12    VALUE REFRESH-KEY
CHAR Q    VALUE QUIT-KEY

VARIABLE SCORE
VARIABLE PIECES
VARIABLE LEVELS
VARIABLE DELAY

VARIABLE BROW            \ where the brick is
VARIABLE BCOL


\ stupid random number generator

VARIABLE SEED

: RANDOMIZE    TIME&DATE + + + + + SEED ! ;

: RANDOM    \ max --- n ; return random number < max
        SEED @ 1103515245 * 12345 + [ HEX ] 07FFF [ DECIMAL ] AND
        DUP SEED !  SWAP MOD ;


\ Access pairs of characters in memory:

: 2C@        DUP 1+ C@ SWAP C@ ;
: 2C!        DUP >R C! R> 1+ C! ;

: <=        > INVERT ;
: >=        < INVERT ;
: D<>        D= INVERT ;


\ Drawing primitives:

: 2EMIT        EMIT EMIT ;

: POSITION    \ row col --- ; cursor to the position in the pit
        2* COL0 + SWAP ROW0 + AT-XY ;

: STONE        \ c1 c2 --- ; draw or undraw these two characters
        WIPING @ IF  2DROP 2 SPACES  ELSE  2EMIT  THEN ;


\ Define the pit where bricks fall into:

: DEF-PIT    CREATE    WIDE DEEP * 2* ALLOT
        DOES>    ROT WIDE * ROT + 2* CHARS + ;

DEF-PIT PIT

: EMPTY-PIT    DEEP 0 DO WIDE 0 DO  EMPTY J I PIT 2C!
        LOOP LOOP ;


\ Displaying:

: DRAW-BOTTOM    \ --- ; redraw the bottom of the pit
        DEEP -1 POSITION
        [CHAR] + DUP STONE
        WIDE 0 DO  [CHAR] = DUP STONE  LOOP
        [CHAR] + DUP STONE ;

: DRAW-FRAME    \ --- ; draw the border of the pit
        DEEP 0 DO
            I -1   POSITION [CHAR] | DUP STONE
            I WIDE POSITION [CHAR] | DUP STONE
        LOOP  DRAW-BOTTOM ;

: BOTTOM-MSG    \ addr cnt --- ; output a message in the bottom of the pit
        DEEP OVER 2/ WIDE SWAP - 2/ POSITION TYPE ;

: DRAW-LINE    \ line ---
        DUP 0 POSITION  WIDE 0 DO  DUP I PIT 2C@ 2EMIT  LOOP  DROP ;

: DRAW-PIT    \ --- ; draw the contents of the pit
        DEEP 0 DO  I DRAW-LINE  LOOP ;

: SHOW-KEY    \ char --- ; visualization of that character
        DUP BL <
        IF  [CHAR] @ OR  [CHAR] ^ EMIT  EMIT  SPACE
        ELSE  [CHAR] ` EMIT  EMIT  [CHAR] ' EMIT
        THEN ;

: SHOW-HELP    \ --- ; display some explanations
        30  1 AT-XY ." ***** T E T R I S *****"
        30  2 AT-XY ." ======================="
        30  4 AT-XY ." Use keys:"
        32  5 AT-XY LEFT-KEY    SHOW-KEY ."  Move left"
        32  6 AT-XY ROT-KEY    SHOW-KEY ."  Rotate"
        32  7 AT-XY RIGHT-KEY    SHOW-KEY ."  Move right"
        32  8 AT-XY DROP-KEY    SHOW-KEY ."  Drop"
        32  9 AT-XY PAUSE-KEY    SHOW-KEY ."  Pause"
        32 10 AT-XY REFRESH-KEY    SHOW-KEY ."  Refresh"
        32 11 AT-XY QUIT-KEY    SHOW-KEY ."  Quit"
        32 13 AT-XY ." -> "
        30 16 AT-XY ." Score:"
        30 17 AT-XY ." Pieces:"
        30 18 AT-XY ." Levels:"
         0 22 AT-XY ."  ======= This program was written 1994 in ANS Forth by Dirk Uwe Zoller ========"
         0 23 at-xy ."  =================== Copy it, port it, play it, enjoy it! =====================" ;

: UPDATE-SCORE    \ --- ; display current score
        38 16 AT-XY SCORE @ 3 .R
        38 17 AT-XY PIECES @ 3 .R
        38 18 AT-XY LEVELS @ 3 .R ;

: REFRESH    \ --- ; redraw everything on screen
        PAGE DRAW-FRAME DRAW-PIT SHOW-HELP UPDATE-SCORE ;


\ Define shapes of bricks:

: DEF-BRICK    CREATE    4 0 DO
                ' EXECUTE  0 DO  DUP I CHARS + C@ C,  LOOP DROP
                REFILL DROP
            LOOP
        DOES>    ROT 4 * ROT + 2* CHARS + ;

DEF-BRICK BRICK1    S"         "
            S" ######  "
            S"   ##    "
            S"         "

DEF-BRICK BRICK2    S"         "
            S" <><><><>"
            S"         "
            S"         "

DEF-BRICK BRICK3    S"         "
            S"   {}{}{}"
            S"   {}    "
            S"         "

DEF-BRICK BRICK4    S"         "
            S" ()()()  "
            S"     ()  "
            S"         "

DEF-BRICK BRICK5    S"         "
            S"   [][]  "
            S"   [][]  "
            S"         "

DEF-BRICK BRICK6    S"         "
            S" @@@@    "
            S"   @@@@  "
            S"         "

DEF-BRICK BRICK7    S"         "
            S"   %%%%  "
            S" %%%%    "
            S"         "

\ this brick is actually in use:

DEF-BRICK BRICK        S"         "
            S"         "
            S"         "
            S"         "

DEF-BRICK SCRATCH    S"         "
            S"         "
            S"         "
            S"         "

CREATE BRICKS    ' BRICK1 ,  ' BRICK2 ,  ' BRICK3 ,  ' BRICK4 ,
        ' BRICK5 ,  ' BRICK6 ,  ' BRICK7 ,

CREATE BRICK-VAL 1 C, 2 C, 3 C, 3 C, 4 C, 5 C, 5 C,


: IS-BRICK    \ brick --- ; activate a shape of brick
        >BODY ['] BRICK >BODY 32 CMOVE ;

: NEW-BRICK    \ --- ; select a new brick by random, count it
        1 PIECES +!  7 RANDOM
        BRICKS OVER CELLS + @ IS-BRICK
        BRICK-VAL SWAP CHARS + C@ SCORE +! ;

: ROTLEFT    4 0 DO 4 0 DO
            J I BRICK 2C@  3 I - J SCRATCH 2C!
        LOOP LOOP
        ['] SCRATCH IS-BRICK ;

: ROTRIGHT    4 0 DO 4 0 DO
            J I BRICK 2C@  I 3 J - SCRATCH 2C!
        LOOP LOOP
        ['] SCRATCH IS-BRICK ;

: DRAW-BRICK    \ row col ---
        4 0 DO 4 0 DO
            J I BRICK 2C@  EMPTY D<>
            IF  OVER J + OVER I +  POSITION
            J I BRICK 2C@  STONE
            THEN
        LOOP LOOP  2DROP ;

: SHOW-BRICK    FALSE WIPING ! DRAW-BRICK ;
: HIDE-BRICK    TRUE  WIPING ! DRAW-BRICK ;

: PUT-BRICK    \ row col --- ; put the brick into the pit
        4 0 DO 4 0 DO
            J I BRICK 2C@  EMPTY D<>
            IF  OVER J +  OVER I +  PIT
            J I BRICK 2C@  ROT 2C!
            THEN
        LOOP LOOP  2DROP ;

: REMOVE-BRICK    \ row col --- ; remove the brick from that position
        4 0 DO 4 0 DO
            J I BRICK 2C@  EMPTY D<>
            IF  OVER J + OVER I + PIT EMPTY ROT 2C!  THEN
        LOOP LOOP  2DROP ;

: TEST-BRICK    \ row col --- flag ; could the brick be there?
        4 0 DO 4 0 DO
            J I BRICK 2C@ EMPTY D<>
            IF  OVER J +  OVER I +
            OVER DUP 0< SWAP DEEP >= OR
            OVER DUP 0< SWAP WIDE >= OR
            2SWAP PIT 2C@  EMPTY D<>
            OR OR IF  UNLOOP UNLOOP 2DROP FALSE  EXIT  THEN
            THEN
        LOOP LOOP  2DROP TRUE ;

: MOVE-BRICK    \ rows cols --- flag ; try to move the brick
        BROW @ BCOL @ REMOVE-BRICK
        SWAP BROW @ + SWAP BCOL @ + 2DUP TEST-BRICK
        IF  BROW @ BCOL @ HIDE-BRICK
            2DUP BCOL ! BROW !  2DUP SHOW-BRICK PUT-BRICK  TRUE
        ELSE  2DROP BROW @ BCOL @ PUT-BRICK  FALSE
        THEN ;

: ROTATE-BRICK    \ flag --- flag ; left/right, success
        BROW @ BCOL @ REMOVE-BRICK
        DUP IF  ROTRIGHT  ELSE  ROTLEFT  THEN
        BROW @ BCOL @ TEST-BRICK
        OVER IF  ROTLEFT  ELSE  ROTRIGHT  THEN
        IF  BROW @ BCOL @ HIDE-BRICK
            IF  ROTRIGHT  ELSE  ROTLEFT  THEN
            BROW @ BCOL @ PUT-BRICK
            BROW @ BCOL @ SHOW-BRICK  TRUE
        ELSE  DROP FALSE  THEN ;

: INSERT-BRICK    \ row col --- flag ; introduce a new brick
        2DUP TEST-BRICK
        IF  2DUP BCOL ! BROW !
            2DUP PUT-BRICK  DRAW-BRICK  TRUE
        ELSE  2DROP FALSE  THEN ;

: DROP-BRICK    \ --- ; move brick down fast
        BEGIN  1 0 MOVE-BRICK 0=  UNTIL ;

: MOVE-LINE    \ from to ---
        OVER 0 PIT  OVER 0 PIT  WIDE 2*  CMOVE  DRAW-LINE
        DUP 0 PIT  WIDE 2*  BLANK  DRAW-LINE ;

: LINE-FULL    \ line-no --- flag
        TRUE  WIDE 0
        DO  OVER I PIT 2C@ EMPTY D=
            IF  DROP FALSE  LEAVE  THEN
        LOOP NIP ;

: REMOVE-LINES    \ ---
        DEEP DEEP
        BEGIN
            SWAP
            BEGIN  1- DUP 0< IF  2DROP EXIT  THEN  DUP LINE-FULL
            WHILE  1 LEVELS +!  10 SCORE +!  REPEAT
            SWAP 1-
            2DUP <> IF  2DUP MOVE-LINE  THEN
        AGAIN ;

: TO-UPPER    \ char --- char ; convert to upper case
        DUP [CHAR] a >= OVER [CHAR] z <= AND
        IF  [ CHAR A CHAR a - ] LITERAL +  THEN ;

: DISPATCH    \ key --- flag
        CASE  TO-UPPER
            LEFT-KEY    OF  0 -1 MOVE-BRICK DROP  ENDOF
            RIGHT-KEY    OF  0  1 MOVE-BRICK DROP  ENDOF
            ROT-KEY    OF  0 ROTATE-BRICK DROP  ENDOF
            DROP-KEY    OF  DROP-BRICK  ENDOF
            PAUSE-KEY    OF  S"  Paused " BOTTOM-MSG  KEY DROP
                    DRAW-BOTTOM  ENDOF
            REFRESH-KEY    OF  REFRESH  ENDOF
            QUIT-KEY    OF  FALSE EXIT  ENDOF
        ENDCASE  TRUE ;

: INITIALIZE    \ --- ; prepare for playing
        RANDOMIZE EMPTY-PIT REFRESH
        0 SCORE !  0 PIECES !  0 LEVELS !  100 DELAY ! ;

: ADJUST-DELAY    \ --- ; make it faster with increasing score
        LEVELS @
        DUP  50 < IF  100 OVER -  ELSE
        DUP 100 < IF   62 OVER 4 / -  ELSE
        DUP 500 < IF   31 OVER 16 / -  ELSE  0  THEN THEN THEN
        DELAY !  DROP ;

: PLAY-GAME    \ --- ; play one tetris game
        BEGIN
            NEW-BRICK
            -1 3 INSERT-BRICK
        WHILE
            BEGIN  4 0
            DO  35 13 AT-XY
                DELAY @ MS KEY?
                IF  BEGIN  KEY KEY? WHILE  DROP  REPEAT
                DISPATCH 0=
                IF  UNLOOP EXIT  THEN
                THEN
            LOOP
            1 0 MOVE-BRICK  0=
            UNTIL
            REMOVE-LINES
            UPDATE-SCORE
            ADJUST-DELAY
        REPEAT ;

FORTH DEFINITIONS

: TT        \ --- ; play the tetris game
        INITIALIZE
        S"  Press any key " BOTTOM-MSG KEY DROP DRAW-BOTTOM
        BEGIN
            PLAY-GAME
            S"  Again? " BOTTOM-MSG KEY TO-UPPER [CHAR] Y =
        WHILE  INITIALIZE  REPEAT
        0 23 AT-XY CR ;

ONLY FORTH ALSO DEFINITIONS